home *** CD-ROM | disk | FTP | other *** search
/ SGI Developer Toolbox 6.1 / SGI Developer Toolbox 6.1 - Disc 4.iso / lib / mathlib / libblas / src_original / ssyr.f < prev    next >
Encoding:
Text File  |  1994-08-02  |  5.9 KB  |  201 lines
  1. *
  2. ************************************************************************
  3. *
  4.       SUBROUTINE SSYR  ( UPLO, N, ALPHA, X, INCX, A, LDA )
  5. *     .. Scalar Arguments ..
  6.       REAL               ALPHA
  7.       INTEGER            INCX, LDA, N
  8.       CHARACTER*1        UPLO
  9. *     .. Array Arguments ..
  10.       REAL               A( LDA, * ), X( * )
  11. *     ..
  12. *
  13. *  Purpose
  14. *  =======
  15. *
  16. *  SSYR   performs the symmetric rank 1 operation
  17. *
  18. *     A := alpha*x*x' + A,
  19. *
  20. *  where alpha is a real scalar, x is an n element vector and A is an
  21. *  n by n symmetric matrix.
  22. *
  23. *  Parameters
  24. *  ==========
  25. *
  26. *  UPLO   - CHARACTER*1.
  27. *           On entry, UPLO specifies whether the upper or lower
  28. *           triangular part of the array A is to be referenced as
  29. *           follows:
  30. *
  31. *              UPLO = 'U' or 'u'   Only the upper triangular part of A
  32. *                                  is to be referenced.
  33. *
  34. *              UPLO = 'L' or 'l'   Only the lower triangular part of A
  35. *                                  is to be referenced.
  36. *
  37. *           Unchanged on exit.
  38. *
  39. *  N      - INTEGER.
  40. *           On entry, N specifies the order of the matrix A.
  41. *           N must be at least zero.
  42. *           Unchanged on exit.
  43. *
  44. *  ALPHA  - REAL            .
  45. *           On entry, ALPHA specifies the scalar alpha.
  46. *           Unchanged on exit.
  47. *
  48. *  X      - REAL             array of dimension at least
  49. *           ( 1 + ( n - 1 )*abs( INCX ) ).
  50. *           Before entry, the incremented array X must contain the n
  51. *           element vector x.
  52. *           Unchanged on exit.
  53. *
  54. *  INCX   - INTEGER.
  55. *           On entry, INCX specifies the increment for the elements of
  56. *           X. INCX must not be zero.
  57. *           Unchanged on exit.
  58. *
  59. *  A      - REAL             array of DIMENSION ( LDA, n ).
  60. *           Before entry with  UPLO = 'U' or 'u', the leading n by n
  61. *           upper triangular part of the array A must contain the upper
  62. *           triangular part of the symmetric matrix and the strictly
  63. *           lower triangular part of A is not referenced. On exit, the
  64. *           upper triangular part of the array A is overwritten by the
  65. *           upper triangular part of the updated matrix.
  66. *           Before entry with UPLO = 'L' or 'l', the leading n by n
  67. *           lower triangular part of the array A must contain the lower
  68. *           triangular part of the symmetric matrix and the strictly
  69. *           upper triangular part of A is not referenced. On exit, the
  70. *           lower triangular part of the array A is overwritten by the
  71. *           lower triangular part of the updated matrix.
  72. *
  73. *  LDA    - INTEGER.
  74. *           On entry, LDA specifies the first dimension of A as declared
  75. *           in the calling (sub) program. LDA must be at least
  76. *           max( 1, n ).
  77. *           Unchanged on exit.
  78. *
  79. *
  80. *  Level 2 Blas routine.
  81. *
  82. *  -- Written on 22-October-1986.
  83. *     Jack Dongarra, Argonne National Lab.
  84. *     Jeremy Du Croz, Nag Central Office.
  85. *     Sven Hammarling, Nag Central Office.
  86. *     Richard Hanson, Sandia National Labs.
  87. *
  88. *
  89. *     .. Parameters ..
  90.       REAL               ZERO
  91.       PARAMETER        ( ZERO = 0.0E+0 )
  92. *     .. Local Scalars ..
  93.       REAL               TEMP
  94.       INTEGER            I, INFO, IX, J, JX, KX
  95. *     .. External Functions ..
  96.       LOGICAL            LSAME
  97.       EXTERNAL           LSAME
  98. *     .. External Subroutines ..
  99.       EXTERNAL           XERBLA
  100. *     .. Intrinsic Functions ..
  101.       INTRINSIC          MAX
  102. *     ..
  103. *     .. Executable Statements ..
  104. *
  105. *     Test the input parameters.
  106. *
  107.       INFO = 0
  108.       IF     ( .NOT.LSAME( UPLO, 'U' ).AND.
  109.      $         .NOT.LSAME( UPLO, 'L' )      )THEN
  110.          INFO = 1
  111.       ELSE IF( N.LT.0 )THEN
  112.          INFO = 2
  113.       ELSE IF( INCX.EQ.0 )THEN
  114.          INFO = 5
  115.       ELSE IF( LDA.LT.MAX( 1, N ) )THEN
  116.          INFO = 7
  117.       END IF
  118.       IF( INFO.NE.0 )THEN
  119.          CALL XERBLA( 'SSYR  ', INFO )
  120.          RETURN
  121.       END IF
  122. *
  123. *     Quick return if possible.
  124. *
  125.       IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )
  126.      $   RETURN
  127. *
  128. *     Set the start point in X if the increment is not unity.
  129. *
  130.       IF( INCX.LE.0 )THEN
  131.          KX = 1 - ( N - 1 )*INCX
  132.       ELSE IF( INCX.NE.1 )THEN
  133.          KX = 1
  134.       END IF
  135. *
  136. *     Start the operations. In this version the elements of A are
  137. *     accessed sequentially with one pass through the triangular part
  138. *     of A.
  139. *
  140.       IF( LSAME( UPLO, 'U' ) )THEN
  141. *
  142. *        Form  A  when A is stored in upper triangle.
  143. *
  144.          IF( INCX.EQ.1 )THEN
  145.             DO 20, J = 1, N
  146.                IF( X( J ).NE.ZERO )THEN
  147.                   TEMP = ALPHA*X( J )
  148.                   DO 10, I = 1, J
  149.                      A( I, J ) = A( I, J ) + X( I )*TEMP
  150.    10             CONTINUE
  151.                END IF
  152.    20       CONTINUE
  153.          ELSE
  154.             JX = KX
  155.             DO 40, J = 1, N
  156.                IF( X( JX ).NE.ZERO )THEN
  157.                   TEMP = ALPHA*X( JX )
  158.                   IX   = KX
  159.                   DO 30, I = 1, J
  160.                      A( I, J ) = A( I, J ) + X( IX )*TEMP
  161.                      IX        = IX        + INCX
  162.    30             CONTINUE
  163.                END IF
  164.                JX = JX + INCX
  165.    40       CONTINUE
  166.          END IF
  167.       ELSE
  168. *
  169. *        Form  A  when A is stored in lower triangle.
  170. *
  171.          IF( INCX.EQ.1 )THEN
  172.             DO 60, J = 1, N
  173.                IF( X( J ).NE.ZERO )THEN
  174.                   TEMP = ALPHA*X( J )
  175.                   DO 50, I = J, N
  176.                      A( I, J ) = A( I, J ) + X( I )*TEMP
  177.    50             CONTINUE
  178.                END IF
  179.    60       CONTINUE
  180.          ELSE
  181.             JX = KX
  182.             DO 80, J = 1, N
  183.                IF( X( JX ).NE.ZERO )THEN
  184.                   TEMP = ALPHA*X( JX )
  185.                   IX   = JX
  186.                   DO 70, I = J, N
  187.                      A( I, J ) = A( I, J ) + X( IX )*TEMP
  188.                      IX        = IX        + INCX
  189.    70             CONTINUE
  190.                END IF
  191.                JX = JX + INCX
  192.    80       CONTINUE
  193.          END IF
  194.       END IF
  195. *
  196.       RETURN
  197. *
  198. *     End of SSYR  .
  199. *
  200.       END
  201.